home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-19
/
mar93.zip
/
PARABOLA.LSP
< prev
next >
Wrap
Lisp/Scheme
|
1993-02-13
|
7KB
|
229 lines
;==========================================================
; PARABOLA.LSP Copyright 1992 by Looking Glass Microproducts
;==========================================================
(if (null PARABOLA_SEGS)
(setq PARABOLA_SEGS 12) ; default number of parabola segments
)
(defun C:PARABOLA (/ ERROR PUSHVARS POPVARS NOTRANS PARABOLA SQR
MIDPOINT 2D RTOD SYSVARS)
;==========================================================
; Error Handler
(defun ERROR (S)
(if (not
(member
S
'("Function cancelled" "console break")
)
)
(princ S)
)
(command "_undo" "end")
(command "_undo" "1")
(POPVARS)
)
;==========================================================
; Set and Save System Variables
(defun PUSHVARS (VLIST)
(foreach PAIR VLIST
(setq
SYSVARS (cons
(cons
(strcase (car PAIR))
(getvar
(car PAIR)
)
)
SYSVARS
)
)
(if (cdr PAIR) (setvar (car PAIR) (cdr PAIR)))
)
t
)
;==========================================================
; Restore System Variables
(defun POPVARS ()
(foreach PAIR SYSVARS (setvar (car PAIR) (cdr PAIR)))
(setq
*error* OLD-ERROR
)
(setq SYSVARS nil)
(princ)
)
;==========================================================
; Restore a single system variable from stack
(defun RESTORE (VARNAME / OLD-VALUE)
(if (setq
OLD-VALUE (cdr (assoc (strcase VARNAME) SYSVARS))
)
(setvar VARNAME OLD-VALUE)
)
)
;==========================================================
; Disallow transparent invocation of routine.
(defun NOTRANS ()
(cond
((zerop (logand (getvar "cmdactive") (+ 1 2 4 8))))
((alert
"This command may not be invoked transparently."
)
)
)
)
;===========================================================
; Square function
(defun SQR (X) (* X X))
;===========================================================
; Midpoint between p1 and p2
(defun MIDPOINT (P1 P2)
(mapcar '(lambda (X1 X2) (* 0.5 (+ X1 X2))) P1 P2)
)
;===========================================================
; Set z to zero
(defun 2D (P) (mapcar '* P '(1 1)))
;==========================================================
; Radians to degrees
(defun RTOD (X) (/ (* 180.0 X) pi))
;===========================================================
; extended getint
(defun XGETINT (PRMPT DEFAULT)
(cond
((getint (strcat PRMPT " <" (itoa DEFAULT) ">: ")))
(DEFAULT
)
)
)
;============================================================
; List of points on parabola with vertex at p0 through p1
(defun PARAB (P0 P1 / X0 X1 Y0 Y1 A DX POINTS X Y)
(setq X0 (car P0) Y0 (cadr P0) X1 (car P1) Y1 (cadr P1))
(if (/= X0 X1)
(progn
(setq
A (/ (- Y1 Y0) (SQR (- X1 X0)))
DX (/ (* 2 (- X1 X0)) PARABOLA_SEGS)
POINTS (list (list X1 Y1))
X X1
)
(repeat
PARABOLA_SEGS
(setq
X (- X DX)
Y (+ (* A (SQR (- X X0))) Y0)
POINTS (cons (list X Y) POINTS)
)
)
POINTS
)
)
)
;==========================================================
; Parabola main routine
(defun PARABOLA (/ P0 P1 P1W P2 P3 P3W POINTS ANG)
(graphscr)
(initget 1 "Segments")
(setq
P0 (getpoint "\nSegments/<start point>: ")
)
(if (= "Segments" P0)
(progn
(initget 6) ; disallow zero, negative
(setq
PARABOLA_SEGS (*
(/
(1+
(XGETINT
"\nNumber of segments"
PARABOLA_SEGS
)
)
2
)
2
)
)
(initget 1) ; disallow nil input
(setq P0 (getpoint "\nStart point: "))
)
)
(setq P0 (2D P0))
;
(initget 1)
(setq P1 (2D (getpoint P0 "\nEnd point: ")))
(while (equal P0 P1)
(prompt
"\nPoints must be distinct."
)
(initget 1)
(setq
P1 (2D (getpoint P0 "\nTry again: "))
)
)
;
(setq P2 (MIDPOINT P0 P1) ANG (angle P0 P1))
(setvar
"blipmode" 0
)
(command "_snap" "rotate" P2 (RTOD ANG))
(RESTORE
"snapmode"
)
(RESTORE "blipmode")
(setvar "orthomode" 1)
;
(grdraw P0 P1 -1)
(initget 1) ; disallow nil zero inputs
(setq P3 (getpoint P2 "\nVertex: "))
(grdraw P0 P1 -1)
;
(command "_undo" "1")
;
(setq P1W (trans P1 1 0) P3W (trans P3 1 0))
(setvar
"blipmode" 0
)
(command
"_ucs" "3p" P2 P1
(polar P2 (+ ANG (* 0.5 pi)) 1)
)
(setq P1 (trans P1W 0 1) P3 (trans P3W 0 1))
(setq
P3 (mapcar '* P3 '(0 1))
)
(setq POINTS (PARAB P3 P1))
(setvar "osmode" 0)
(command "_pline")
(apply 'command POINTS)
(command "")
(command "_pedit" (entlast) "f" "")
(command "_ucs" "p")
)
;==========================================================
; Body of PARABOLA Command
(if (NOTRANS)
(progn
(setq OLD-ERROR *error* *error* ERROR)
(PUSHVARS
'(("cmdecho" . 0)
("plinewid" . 0)
("plinegen" . 1)
("orthomode")
("blipmode")
("osmode")
("snapmode")
)
)
(command "_undo" "group")
(PARABOLA)
(command "_undo" "end")
(POPVARS)
)
(princ)
)
)
(princ
" PARABOLA.LSP (Copyright 1992 by Looking Glass Microproducts) loaded."
)
(princ)